フォルダ内のファイルを読み込んでデータを１つにまとめるマクロ（vba）

☆１つずつファイルを開けてコピー＆ペーストは大変です

　フォルダにエクセルファイルが多数あり、その中の一つひとつを読み込んで
　一つのエクセルファイルにまとめる場合があります。
　手作業でもできますが、マクロでできると便利です。
　フォルダ名(この例では、c:\temp\）や、データがあるセルの場所、まとめ方などは
　適宜改造してお使い下さい。

☆このマクロでできること

　c:\temp\dataにまとめたいエクセルファイルがある場合です。
　例：
　　　Sample1.xlsx のA1セルに100
　　　Sample2.xlsx のA1セルに200
　　　Sample3.xlsx のA1セルに500

　が入っていて c:\temp\にこのマクロを保存しているエクセルファイルがあり、
　c:\temp\Answer.xlsxにファイル名とデータをまとめる場合。

　　　

☆使い方

下に掲載したコードをコピーして、
網掛けしたいシートがあるご自身のファイルを開きます。その後、マクロのウィンドウでコードをペーストしてください。

こうすることで、マクロがダウンロードできない環境でも
マクロの実行さえできれば、マクロを使うことができます。

☆コード（カットアンドペーストでdataを集める場合）


Sub DataSyukei()
'
    Dim myPath As String, myBook As String
    Dim Answer As Workbook
    
    Dim xlLastRow As Long       'Excel自体の最終行
    Dim LastRow As Long         '最終行
    
    Application.ScreenUpdating = False  '画面の書き換えをOFF

    myPath = "C:\temp\data\"            'データファイルのパスをここで指定
    myBook = Dir(myPath & "*.xlsx")
    

    Do Until myBook = ""        'ファイル名が取得できる間繰り返す
    
        Workbooks.Open myPath & myBook
        
        'Sheets("データがはいているシート").Select　（シートを指定する場合）
        Range("A1:B2").Select      '（A1セルからB2セルまでをコピーする場合）
        Selection.Copy
                        
        '集計先のファイル名 Workbook型の変数で受けると開くことができる
        '(C:\temp\にAnswer.xlsxという結果を回収するファイルを準備)
        Set Answer = Workbooks.Open("C:\temp\Answer.xlsx")
       
        xlLastRow = Cells(Rows.Count, 1).Row          'Excelの最終行
        LastRow = Cells(xlLastRow, 2).End(xlUp).Row   '列の最終行を取得
        
        Windows("Answer.xlsx").Activate
 
        Cells(LastRow + 1, 2).Value = myBook        'ファイル名を2列目に入力
        Cells(LastRow + 1, 3).Select                '3列目を選択
    
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
        Application.CutCopyMode = False             'クリップボードダイアログOFF
        
        Workbooks(myBook).Close SaveChanges:=True   '保存して閉じる
        Answer.Close SaveChanges:=True              '出力ファイルを一度保存して閉じる

        
        myBook = Dir                                '次のファイル名を取得
        
    Loop
    
    'クリップボードダイアログ　ON
    Application.CutCopyMode = True
    
    '画面の書き換えを元に戻す
    Application.ScreenUpdating = True
    
    'Answer.xlsx　を開いて終了する
    Set Answer = Workbooks.Open("C:\temp\Answer.xlsx")  '(C:\temp\にAnswer.xlsxという結果を回収するファイルを準備)
    
End Sub

☆コード（セルの値を取得する場合）


Sub data_gather()
    Dim myPath As String, myBook As String
    Dim Answer As Workbook
    
    Dim xlLastRow As Long       'Excel自体の最終行
    Dim LastRow As Long         '最終行
    
    Dim atai As Long            '取得するセルが数値の場合

    Application.ScreenUpdating = False  '画面の書き換えをOFF

    myPath = "c:\temp\data\"            'データファイルのパスをここで指定
    myBook = Dir(myPath & "*.xlsx")
    
    
    Do Until myBook = ""        'ファイル名が取得できる間繰り返す
    
        Workbooks.Open myPath & myBook
        atai = Range("A1").Value                    'A1にある数値を集める場合
        Workbooks(myBook).Close SaveChanges:=True   '保存して閉じる
        
        Set Answer = Workbooks.Open("C:\temp\Answer.xlsx")  '集計するファイル名
        
        xlLastRow = Cells(Rows.Count, 1).Row  'Excelの最終行
        LastRow = Cells(xlLastRow, 2).End(xlUp).Row   'D列の最終行を取得
        
        Cells(LastRow + 1, 2).Value = myBook    'ファイル名を2列目に入力
        Cells(LastRow + 1, 3).Value = atai      '値(atai)　を3列目に入力
        
        Answer.Close SaveChanges:=True          '出力ファイルを一度保存して閉じる
        
        myBook = Dir                            '次のファイル名を取得
        
    Loop
    
    Application.ScreenUpdating = True   '画面の書き換えを元に戻す

    'Answer.xlsx　を開いて終了する
    Set Answer = Workbooks.Open("C:\temp\Answer.xlsx")  '(C:\temp\にAnswer.xlsxという結果を回収するファイルを準備)
    
End Sub

☆参考文献

(1) EXCELマクロ＆VBAプロ技セレクション　技術評論社

←戻る